Class XmpBlock
'Extracts the XMP metadata from an Adobe edited JPEG file
'and makes it simpler to access the data, although not all
'values are captured, only the ones that I want so far :).
'
'(C) Copyright Russell Pitcher 2008
'Enquiries: mail russ@theatre64.org
'
'Version 1.0
	
	Private c_strXMP
	Private c_rsXMP
	Private c_objConn
	Private c_blnLoaded
	Private c_blnDecoded
	Private c_strJpegFile
	Private c_objFSO
	Private c_errDesc
	Private c_errFunc
	Private c_xmlXMP
	
	Private Sub Class_Initialize
		Set c_xmlXMP   = CreateObject("Msxml2.DOMDocument.6.0")
		c_xmlXMP.async = False
		Set c_objFSO = CreateObject("Scripting.FileSystemObject")
		Set c_rsXMP  = CreateObject("ADOR.Recordset")
		'adVarChar = 200
		c_rsXMP.Fields.Append "Namespace", 200, 20
		c_rsXMP.Fields.Append "Property",  200, 30
		c_rsXMP.Fields.Append "Value",     200, 255
		c_rsXMP.Open
	End Sub
		
	Public Property Let FileName(JpegFile)
	'Set the file name from which to extract the XMP data
		c_strJpegFile = JpegFile
	End Property
	
	Public Property Get ErrDesc
		ErrDesc = c_errDesc
	End Property
	
	Public Property Get ErrFunc
		ErrDesc = c_errFunc
	End Property
	
	Public Property Get FileName
	'Get the file name for the current XMP block
		FileName = strJpegFile
	End Property
	
	Public Property Get Decoded()
	'Return True if XMP has been successfully loaded
		If c_blnDecoded Then
			Decoded = True
		Else
			Decoded = False
		End If
	End Property
	
	Public Property Get Loaded()
	'Return True if XMP has been successfully loaded
		If c_blnLoaded Then
			Loaded = True
		Else
			Loaded = False
		End If
	End Property
	
	Public Property Get Item(PropertyName)
	'Get the value for a given Property
'		On Error Resume Next
		c_errDesc = ""
		c_errFunc = ""
		c_rsXMP.Filter = " Property = '" & PropertyName & "'"
	
		If c_rsXMP.RecordCount = 0 Then
			Item = " - "
		Else
			c_rsXMP.MoveFirst
			Item = c_rsXMP("Value")
		End If
		c_rsXMP.Filter = ""
	End Property
		
	Public Function GetXmp()
	'Load the XMP block from the JPEG file specified in the [FileName] property
	'Returns True if successful
		On Error Resume Next
		c_errDesc = ""
		c_errFunc = ""
		If c_objFSO.FileExists(c_strJpegFile) Then
			c_xmlXMP.loadXML(GetXmpBlock(c_strJpegFile))
			If Err.Number = 0 Then
				c_blnLoaded = True
				If GetProperties = True Then
					GetXmp = True
					c_blnDecoded = True
				Else
					GetXmp = False
					c_blnDecoded = False
				End If
			Else
				c_errDesc = "Cannot retrieve XMP block from file [" & c_strJpegFile & "]"
				c_errFunc = "GetXmp"
				GetXmp = False
			End If
		Else
			c_errDesc = "Cannot find file [" & c_strJpegFile & "]"
			c_errFunc = "GetXmp"
			GetXmp = False
		End If
	End Function
		
	Public Function Exists(PropertyName)
	'Return True if the specified property has been retrieved from [FileName]
		On Error Resume Next
		c_errDesc = ""
		c_errFunc = ""
		c_rsXMP.Filter = " Property = '" & strService & "'"
	
		If c_rsXMP.RecordCount = 0 Then
			Exists = False
		Else
			Exists = True
		End If
		c_rsXMP.Filter = ""
	End Function
		
	Public Function ListProperties()
	'Return a string list of the properties that this class has retrieved from [FileName]
		c_errDesc = ""
		c_errFunc = ""
		c_rsXMP.Sort = "Namespace, Property"
		If c_rsXMP.RecordCount = 0 Then
			c_errDesc = "No properties found"
			c_errFunc = "ListProperties"
		Else
			c_rsXMP.MoveFirst
			Do Until c_rsXMP.EOF
				WScript.Echo c_rsXMP("Namespace") & ":" & c_rsXMP("Property") & " = " & c_rsXMP("Value")
				c_rsXMP.MoveNext
			Loop
		End If
	End Function
		
	Public Function ToDictionary()
	'Export the XMP data to a Dictionary object
		c_errDesc = ""
		c_errFunc = ""
		Dim dctProperties
		Set dctProperties = CreateObject("Scripting.Dictionary")
		
		On Error Resume Next
		If c_rsXMP.RecordCount > 0 Then
			c_rsXMP.MoveFirst
			Do Until c_rsXMP.EOF
				dctProperties.Add c_rsXMP("NameSpace") & ":" & c_rsXMP("Property"), c_rsXMP("Value")
				c_rsXMP.MoveNext
			Loop
			
			Set ToDictionary = dctProperties
		Else
			ToDictionary = "No Records"
			c_errDesc = "No records to add to dictionary"
			c_errFunc = "ToDictionary()"
		End If
	End Function
		
	Public Function ToHtmlTable()
	'Export XMP data to HTML table string
		c_errDesc = ""
		c_errFunc = ""
		ToHtmlTable = "<p>Not yet implemented</p>"
	End Function
	
	Private Function DecodeValue(strType, strValue)
	'Make sense of coded values
		c_errDesc = ""
		c_errFunc = ""
		Select Case strType
			Case "exif:FNumber"
				If Not IsNull(strValue) Then
					Execute("DecodeValue = ""f/"" & " & strValue)
				Else
					DecodeValue = ""
				End If
			Case "exif:FocalLength"
				If Not IsNull(strValue) Then
					Execute("DecodeValue = " & strValue & " & ""mm""")
				Else
					DecodeValue = ""
				End If
			Case "exif:MeteringMode"
				if not isnull(strValue) Then
					select Case strValue
						case 0
							Value = "Unknown"
						case 1
							DecodeValue = "Average"
						case 2
							DecodeValue = "Centre Weighted Average"
						case 3
							DecodeValue = "Spot"
						case 4
							DecodeValue = "Multi-spot"
						case 5
							DecodeValue = "Evaluative"
						case 6
							DecodeValue = "Partial"
						case 255
							DecodeValue = "Other"
						case else
							DecodeValue = "Undefined (" & strValue & ")"
					End select
				end If
			Case "exif:ColorSpace"
				if not isnull(strValue) Then
					select case strValue
						case 1
							DecodeValue = "sRGB"
						case 2
							DecodeValue = "Adobe RGB"
						case 65535
							DecodeValue = "Uncalibrated"
						case else
							DecodeValue = "Undefined (" & strValue & ")"
					End select
				end If
			Case "exif:DateTimeOriginal"
				If Not IsNull(strValue) Then
					DecodeValue = UTC2Date(Replace(Replace(Replace(Replace(strValue, "-" ,""), ":", ""), "T", ""), ".", ""))
				Else
					DecodeValue = ""
				End If
			Case "exif:ExposureProgram"
				If Not IsNull(strValue) Then
					Select Case strValue
						Case 1
							DecodeValue = "Manual"
						Case 2
							DecodeValue = "Program AE"
						Case 3
							DecodeValue = "Aperture Priority AE"
						Case 4
							DecodeValue = "Shutter Priority AE"
						Case 5
							DecodeValue = "Creative (slow speed)"
						Case 6
							DecodeValue = "Action (high speed)"
						Case 7
							DecodeValue = "Portrait"
						Case 8
							DecodeValue = "Landscape"
						Case Else
							DecodeValue = "Unknown (" & strValue & ")"
					End Select
				End If
 			Case "aux:FlashCompensation"
				If Not IsNull(strValue) Then
					If Left(strValue, 1) = "0" Then
						DecodeValue = "0"
					Else
						If Right(strValue, 2) = "/1" Then
							DecodeValue = Left(strValue, Len(strValue) - 2)
						Else
							DecodeValue = strValue
						End If
						If Left(DecodeValue, 1) <> "-" Then DecodeValue = "+" & DecodeValue
					End If
				End If
			Case "exif:ExposureBiasValue"
				If Not IsNull(strValue) Then
					If Left(strValue, 1) = "0" Then
						DecodeValue = "0"
					Else
						If Right(strValue, 2) = "/1" Then
							DecodeValue = Left(strValue, Len(strValue) - 2)
						Else
							DecodeValue = strValue
						End If
						If Left(DecodeValue, 1) <> "-" Then DecodeValue = "+" & DecodeValue
					End If
				End If
			Case Else
				DecodeValue = strValue
		End Select
	End Function
	
	Private Function GetXmpBlock(strFilePath)
		c_errDesc = ""
		c_errFunc = ""
		On Error Resume Next
		Dim filJpeg
		Dim strBit
		Dim strChunk
		Dim blnStart
		Dim blnEnd
		Dim strXMP
		Set filJpeg = c_objFSO.OpenTextfile(strFilePath)
		
		Do Until filJpeg.AtEndOfStream
			strBit = filJpeg.Read(1)
			If strBit = "<" Then
				strChunk = filJpeg.Read(9)
				Select Case strChunk
					Case "x:xmpmeta"
						blnStart = True
					Case "/x:xmpmet" 
						blnEnd = True
				End Select
			End If
			If blnStart Then
				strXMP = strXMP & strBit & strChunk
			End If
			If blnEnd Then
				strXMP = strXMP & "a>"
				Exit Do
			End If
			strChunk = ""
		Loop
		
		GetXmpBlock = strXMP
	End Function
	
	Private Function GetProperties
	'Get properties from attributes and tags
		Dim colAttr
		Dim objAttr
		c_errDesc = ""
		c_errFunc = ""
		On Error GoTo 0
		'#region <Get rdf:Description attributes>
		Set colAttr = c_xmlXMP.getElementsByTagName("rdf:Description").item(0).attributes
		For Each objAttr In colAttr
			c_rsXMP.AddNew
				c_rsXMP("Namespace") = Left(objAttr.name, InStr(objAttr.name, ":") - 1)
				c_rsXMP("Property")  = Mid(objAttr.name, InStr(objAttr.name, ":") + 1)
				c_rsXMP("Value")     = DecodeValue(objAttr.Name, objAttr.Text)
			c_rsXMP.Update
		Next
		'#endregion
		'#region <Get ISO Rating>
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "ISOSpeedRatings"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:ISOSpeedRatings").item(0).text
		c_rsXMP.Update
		'#endregion
		'#region <Get Flash Info>
		On Error Resume Next
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "FlashFired"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:Flash").item(0).attributes.getNamedItem("exif:Fired").text
		c_rsXMP.Update
			
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "FlashReturn"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:Flash").item(0).attributes.getNamedItem("exif:Return").text
		c_rsXMP.Update
		
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "FlashMode"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:Flash").item(0).attributes.getNamedItem("exif:Mode").text
		c_rsXMP.Update
			
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "FlashRedEyeMode"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:Flash").item(0).attributes.getNamedItem("exif:RedEyeMode").text
		c_rsXMP.Update
			
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "exif"
			c_rsXMP("Property")  = "FlashFunction"
			c_rsXMP("Value")     = c_xmlXMP.getElementsByTagName("exif:Flash").item(0).attributes.getNamedItem("exif:Function").text
		c_rsXMP.Update
		'#endregion
		'#region <Get Creator info>
		Set colAttr = c_xmlXMP.getElementsByTagName("Iptc4xmpCore:CreatorContactInfo").item(0).attributes
		For Each objAttr In colAttr
			c_rsXMP.AddNew
				c_rsXMP("Namespace") = Left(objAttr.name, InStr(objAttr.name, ":") - 1)
				c_rsXMP("Property")  = Mid(objAttr.name, InStr(objAttr.name, ":") + 1)
				c_rsXMP("Value")     = objAttr.Text
			c_rsXMP.Update
		Next
		
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "dc"
			c_rsXMP("Property")  = "creator"
			c_rsXMP("Value")     = GetDcItem("creator")
		c_rsXMP.Update
		'#endregion
		'#region <Get Description>
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "dc"
			c_rsXMP("Property")  = "description"
			c_rsXMP("Value")     = GetDcItem("description")
		c_rsXMP.Update
		'#endregion
		'#region <Get Copyright>
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "dc"
			c_rsXMP("Property")  = "rights"
			c_rsXMP("Value")     = GetDcItem("rights")
		c_rsXMP.Update
		'#endregion
		'#region <Get Title>
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "dc"
			c_rsXMP("Property")  = "title"
			c_rsXMP("Value")     = GetDcItem("title")
		c_rsXMP.Update
		'#endregion
		'#region <Get Keywords>
		c_rsXMP.AddNew
			c_rsXMP("Namespace") = "dc"
			c_rsXMP("Property")  = "subject"
			c_rsXMP("Value")     = GetDcItem("subject")
		c_rsXMP.Update
		'#endregion
		GetProperties = True
	End Function
	
	Private Function GetDcItem(strNodeName)
	'Retrieve data from dc: tags
		c_errDesc = ""
		c_errFunc = ""
		Dim objNode
		Dim objChildNode
		
		GetDcItem = ""
		On Error Resume Next
		Set objNode = c_xmlXMP.getElementsByTagName("dc:" & strNodeName).item(0).childNodes.item(0).childNodes
		If Err.Number = 0 Then
			For Each objChildNode In objNode
				GetDcItem = GetDcItem & objChildNode.text & ", "
			Next
		Else
			GetDcItem = " - "
		End If
		GetDcItem = Left(GetDcItem, Len(GetDcItem) - 2)
		Set objNode = Nothing
		Set objChildNode = Nothing
	End Function

	Private Function UTC2Date(strUTC)
		UTC2Date = Mid(strUTC, 7, 2) & "/" & Mid(strUTC, 5, 2) & "/" & Left(strUTC, 4) _
			& " " & Mid(strUTC, 9, 2) & ":" & Mid(strUTC, 11,2) & ":" & Mid(strUTC, 13, 2)
	End Function

End Class